open Fr
open FrGui_common
open FrGui_size
open FrGui_widgets

let frame ?label child =
	let widget = GBin.frame ?label () in
	widget#add child#widget;
	new container_widget ~expand: child#expand widget

let scroll_box child =
	let widget = GBin.scrolled_window () in
	widget#add child#widget;
	new container_widget ~expand: child#expand widget

let box orientation ?(separated=false) (children: widget list) =
	let widget =
		GPack.box (gtk_orientation orientation) () in
	if separated then
		match children with
		| first :: rest ->
			widget#pack ~expand: first#expand first#widget;
			List.iter (fun child ->
				ignore (GMisc.separator
					(match orientation with
					| `Horizontal -> `VERTICAL
					| `Vertical -> `HORIZONTAL)
					~packing: widget#pack ());
				widget#pack ~expand: child#expand child#widget) rest
		| [] -> ()
	else
		List.iter (fun child -> widget#pack ~expand: child#expand child#widget) children;
	new container_widget widget

let hbox = box `Horizontal
let vbox = box `Vertical

(* this is a hack, we need a true container *)
let flow (orientation: orientation) ?(justification: justification option) (children: widget list) =
	if orientation = `Vertical then begin
		warn "Vertical orientation not supported for \"flow\" widget in this toolkit; replacing with vbox.";
		match justification with
		| None | Some `Left -> vbox (List.append children [empty])
		| Some `Right -> vbox (empty :: children)
		| Some `Center -> vbox (empty :: (List.append children [empty]))
		| Some `Full -> vbox children
	end else
	let widget = GBin.scrolled_window
		~hpolicy: (if orientation = `Horizontal then `NEVER else `AUTOMATIC)
		~vpolicy: (if orientation = `Vertical then `NEVER else `AUTOMATIC)
		() in
	let buffer = GText.buffer () in
	let view = GText.view
		~buffer
		~editable: false
		~cursor_visible: false
		?justification: (option_map gtk_justification justification)
		~wrap_mode: `CHAR
		~packing: widget#add () in
	let color = `COLOR (view#misc#style#bg `NORMAL) in
	view#misc#modify_base [
		`NORMAL, color;
		`ACTIVE, color;
		`PRELIGHT, color;
		`SELECTED, color;
		`INSENSITIVE, color ];
	begin match orientation with
		| `Horizontal -> view#misc#set_size_request ~width: 1 ()
		| `Vertical -> view#misc#set_size_request ~height: 1 ()
	end;
	List.iter (fun child ->
		let anchor = buffer#create_child_anchor buffer#end_iter in
		view#add_child_at_anchor child#widget anchor) children;
	new container_widget ~expand: true widget

let hflow = flow `Horizontal
let vflow = flow `Vertical

let split orientation ?(position: float option) (children: widget * widget) =
	let widget =
		GPack.paned (gtk_orientation orientation) () in
	widget#pack1 (fst children)#widget;
	widget#pack2 (snd children)#widget;
	if position <> None then
		warn "\"position\" setting of \"split\" widget not supported with this toolkit; ignoring.";
	new container_widget ~expand: true widget

let hsplit = split `Horizontal
let vsplit = split `Vertical

let tabbed ?(position=`North) ?init (children: (string * widget) list) =
	let widget =
		GPack.notebook ~tab_pos: (gtk_position position) () in
	List.iter (fun (name, child) ->
			(* child#widget is not necessarily constant *)
			let cw = child#widget in
			widget#append_page
				~tab_label: (GMisc.label ~text: name ())#coerce
				cw;
			option_may (fun init ->
				if child == init then
					widget#goto_page (widget#page_num cw)) init
		) children;
	new container_widget ~expand: true widget

let sized_box (orientation: [< orientation ] as 'a) ?(separated=false)
		(children: (widget * 'a size_constraint) list) =
	let widget =
		GPack.box (gtk_orientation orientation) () in
	if separated then
		match children with
		| (first, width) :: rest ->
			widget#pack ~expand: first#expand first#widget;
			List.iter (fun (child, width) ->
				ignore (GMisc.separator
					(match orientation with
					| `Horizontal -> `VERTICAL
					| `Vertical -> `HORIZONTAL)
					~packing: widget#pack ());
				widget#pack ~expand: child#expand child#widget) rest
		| [] -> ()
	else
		List.iter
			(fun (child, size) ->
				let w = child#widget in
				GtkPack.SizeGroup.add_widget size w#as_widget;
				widget#pack ~expand: child#expand w)
			children;
	new container_widget widget

let sized_hbox = sized_box `Horizontal
let sized_vbox = sized_box `Vertical

let switch_w init child =
	let widget =
		GBin.frame ~shadow_type: `NONE ~border_width: 0 () in
	widget#add init#widget;
	register_e_with widget
		(on child w ->
			widget#remove widget#child;
			widget#add w#widget);
	new container_widget widget

let collapse_w child =
	let widget =
		GBin.frame ~shadow_type: `NONE ~border_width: 0 () in
	register_b_with widget (lift (
		(try widget#remove widget#child with Gpointer.Null -> ());
		widget#add @child#widget));
	new container_widget widget

let switch_wb init wb =
	switch_w (fst init) (map_e fst wb), switch_b (snd init) (map_e snd wb)

let collapse_wb wb =
	collapse_w (lift1 fst wb), collapse_b (lift1 snd wb)

let switch_we init we =
	switch_w (fst init) (map_e fst we), switch_e (snd init) (map_e snd we)

let collapse_we we =
	collapse_w (lift1 fst we), collapse_e (lift1 snd we)

(* should we have feedback function? *)
let sswitch_wb fi i wbf =
	let widget =
		GBin.frame ~shadow_type: `NONE ~border_width: 0 () in
	let bfi a =
		let w, b = fi a in
		widget#add w#widget;
		b
	in
	let b = sswitch_b id bfi i (on wbf f a ->
		let w, b = f a in
		widget#remove widget#child;
		widget#add w#widget;
		b) in
	register_b_with widget b;
	new container_widget widget, b

let scollapse_wb i wbf =
	let widget =
		GBin.frame ~shadow_type: `NONE ~border_width: 0 () in
	let b = scollapse_b id i (lift (fun a ->
		let w, b = @wbf a in
		(try widget#remove widget#child with _ -> ());
		widget#add w#widget;
		b))
	in
	register_b_with widget b;
	new container_widget widget, b
